################################################################################################################
#########  Description: Application 3 related to count of infected blood cells.
#########  Source: M. J. Crawley. The R book. New York: John Wiley & Sons, 2007.
################################
################################################################################

Dataset <- read.table("G:... /cells.txt", header=TRUE, sep="", na.strings="NA", dec=".", strip.white=TRUE)

attach(Dataset)
y = cells

########################
#### Descritive analysis
########################

FF <- rep(1, length(cells))
YY = aggregate(FF, by = list(weight[1:511], sex[1:511], smoker[1:511], age[1:511]), FUN = "sum")
table(YY)

table(weight,age)
table(weight,age, smoker)

#########################################################
## Figure: Bar plot for the count of infected blood cells
#########################################################

require(Hmisc)
mgp.axis(2, at=c(0, 20, 40, 60, 80), las=2)
heritage <- table(FF, cells)
bp <- barplot(table(FF, cells), main = "Number of infected blood cells", ylim = c(0, 350))
round((table(cells)/length(cells))*100, 1)
labels <-c("61.4%\n(n=314)", "14.7%\n(n=75)", "9.8%\n(n=50)", "6.3%\n(n=32)", "3.5%\n(n=18)", "2.5%\n(n=13)", "1.4%\n(n=7)", "0.4%\n(n=2)")
text(bp, heritage+2, labels, cex=1, pos=3)

which(y >= 7)

##############################################################################
## Figure: Bar plot for the count of infected blood cells for each categorical ## variable.
##############################################################################

a <- which( y > 2 & smoker == FALSE)
a <- which( y > 5 & age == "mid")

counts <- table(smoker, y)
barplot(counts, main = "Infected blood cells by smoke", args.legend = c(title = "Smoke"), legend = c("No", "Yes"), beside=TRUE,  col=c("darkblue","red"))

counts2 <- table(age, y) 
barplot(counts2, main = "Infected blood cells by age", args.legend = c(title = "Age group"), legend = c("Mid", "Old", "Young"), beside=TRUE,  col=c("darkblue","red", "green3"))

counts3 <- table(sex, y) 
barplot(counts3, main = "Infected blood cells by gender", args.legend = c(title = "Gender"), legend = c("Female", "Male"), beside=TRUE,  col=c("darkblue","red"))

counts4 <- table(weight, y) 
barplot(counts4, main = "Infected blood cells by weight", args.legend = c(title = "Weight group"), legend = c("Normal", "Obese", "Over"), beside=TRUE,  col=c("darkblue","red", "green3"))

###############################################
################################# Poisson model 
###############################################

GLM.1 <- glm(cells ~ age*sex*smoker*weight, family=poisson(log), data=Dataset)

GLM.2 <- glm(cells ~  age + sex + smoker + weight + age:smoker + age:weight + sex:smoker + sex:weight + smoker:weight + age:smoker:weight + sex:smoker:weight, family=poisson(log), data=Dataset)
summary(GLM.4)

anova(GLM.1, GLM.2, test= "LRT")

fit.model <- GLM.2
Xe <- model.matrix(fit.model)

Log.vero_Po <- logLik(fit.model)[1] 

X <- Xe
n         = nrow(X)
p         = ncol(X)

AIC(fit.model)

BIC(fit.model)

CAIC = -2*logLik(fit.model)[1] +  dim(Xe)[2]*(log(length(y))+ 1)
CAIC

summary(fit.model)

#---------------------------------------
# Envelope : Poisson regression model
#---------------------------------------

mu_po     = fitted(fit.model)
td_po     = resid(fit.model,type="pearson")

mm        = 200

nresp_po  = matrix(0,n,mm)

###---------------
### Generating mm samples of size n

for(i in 1:mm){
  nresp_po[,i] = rpois(n, mu_po)
}
  resid_po = matrix(0,n,mm)

for(i in 1:mm){

  fit = glm(nresp_po[,i] ~ X, family=poisson)
  
  resid_po[,i]   = resid(fit,type="pearson")
	}
  order_resid_po = matrix(0,n,mm)

for(i in 1:mm){
  order_resid_po[,i] = sort(resid_po[,i])
}

min_res_po  = numeric()
max_res_po  = numeric()
mean_res_po = numeric()

for(i in 1:n){
  min_res_po[i]  = min(order_resid_po[i,])
  max_res_po[i]  = max(order_resid_po[i,])
  mean_res_po[i] = mean(order_resid_po[i,])
}

faixa = range(td_po,min_res_po, max_res_po)

qqnorm(td_po,xlab="Quantiles of N(0,1)", ylim=faixa,ylab="Pearson residue", pch=16, main="Poisson")
par(new=T)
#
qqnorm(min_res_po,axes=F,xlab="",ylab="",type="l", lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(max_res_po,axes=F,xlab="",ylab="", type="l",lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(mean_res_po,axes=F,xlab="", ylab="", type="l", lty=2, main="", ylim=faixa)


####################################################
############################ negative binomial model 
####################################################

require(MASS)

GLM.3 <- glm.nb(cells ~ age*sex*smoker*weight, data=Dataset)

GLM.4 <- glm.nb(cells ~ smoker*weight, data=Dataset)
summary(GLM.4)

anova(GLM.3, GLM.4)

fit.model <- GLM.4
Xe  <-  model.matrix(fit.model)
X      = Xe
n      = nrow(X)
p      = ncol(X)

AIC(fit.model)

BIC(fit.model)

CAIC = -2*logLik(fit.model)[1] + (dim(Xe)[2]+1)*(log(length(y))+ 1)
CAIC

summary(fit.model)

#---------------------------------------
# Envelope : Binomial negative regression model
#---------------------------------------

mu_bn  = fitted(fit.model)
fi     = fit.model$theta

td_bn  = resid(fit.model,type="pearson")

mm       = 200

nresp_bn = matrix(0,n,mm)

###---------------
### Generating mm samples of size n

for(i in 1:mm){
  nresp_bn[,i] = rnegbin(n, mu_bn,fi)
}

resid_bn = matrix(0,n,mm)

for(i in 1:mm){

  fit           = glm.nb(nresp_bn[,i] ~ X, control = glm.control(maxit = 40))
  resid_bn[,i]  = resid(fit,type="pearson")
}

order_resid_bn  = matrix(0,n,mm)

for(i in 1:mm){
  order_resid_bn[,i] = sort(resid_bn[,i])
}

min_res_bn = numeric()
max_res_bn = numeric()
mean_res_bn = numeric()


for(i in 1:n){
min_res_bn[i]  = min(order_resid_bn[i,])
max_res_bn[i]  = max(order_resid_bn[i,])
mean_res_bn[i] = mean(order_resid_bn[i,])
}

faixa = range(td_bn,min_res_bn, max_res_bn)

qqnorm(td_bn,xlab="Quantiles of N(0,1)", ylim=faixa,ylab="Pearson residue", pch=16, main="Negative binomial")
par(new=T)
#
qqnorm(min_res_bn,axes=F,xlab="",ylab="",type="l", lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(max_res_bn,axes=F,xlab="",ylab="", type="l",lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(mean_res_bn,axes=F,xlab="", ylab="", type="l", lty=2, main="", ylim=faixa)

###############################################
################################# ZIP model 
###############################################

require(MASS)
aux <- glm.nb(cells ~ age*sex*smoker*weight, data=Dataset)
Dataset2 <- as.data.frame(model.matrix(aux))
Dataset2 <- Dataset2[, !is.na(coef(aux))]
Dataset2 <- Dataset2[,-1]
names(Dataset2)
Dataset2$cells <- Dataset$cells
names(Dataset2)

require(pscl)
require(lmtest)

fit <- zeroinfl( cells ~. | 1, dist="poisson", data=Dataset2)

fit2 <- zeroinfl( cells ~. - `ageold:sexmale:smokerTRUE:weightobese` - `ageyoung:sexmale:smokerTRUE:weightover`| 1, dist="poisson", data=Dataset2)

waldtest(fit, fit2)
lrtest(fit, fit2)

### Note that fit2 = fit3 ####

fit3 <- zeroinfl( cells ~  (age + sex + smoker + weight)^3| 1, dist="poisson", data = Dataset)
summary(fit3)

fit4 <- zeroinfl( cells ~ sex + smoker + weight + smoker:weight + sex:smoker | 1, dist="poisson", data =Dataset)
summary(fit4)

waldtest(fit4, fit3)
lrtest(fit4, fit3)

fit.model <- fit4

-2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*log(length(cells))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 1)*(log(length(cells))+ 1)
CAIC

#---------------------------------------
# Envelope : ZIP regression model
#---------------------------------------

require(gamlss)

Xe  <-  model.matrix(fit.model)
X      = Xe
n      = nrow(X)
p      = ncol(X)
ls <- dim(X)[2]

beta <- coef(fit.model)[1:ls]
p.zip.lambda <- exp(model.matrix(fit.model) %*% beta)
p.zip.theta <- coef(fit.model)[ls+1]
p <- exp(p.zip.theta)/(exp(p.zip.theta)+1)

td_zip  = resid(fit.model,type="pearson")

mm       = 200

nresp_zip = matrix(0,n,mm)

###---------------
### Generating mm samples of size n
###---------------


for(i in 1:mm){
  nresp_zip[,i] = rZIP2(n,mu=p.zip.lambda,sigma=p) 
}

resid_zip = matrix(0,n,mm)

for(i in 1:mm){

  fit           = zeroinfl(nresp_zip[,i] ~    sex + smoker + weight + smoker:weight + sex:smoker | 1, dist="poisson") 
  resid_zip[,i]  = resid(fit,type="pearson")
}

order_resid_zip  = matrix(0,n,mm)

for(i in 1:mm){
  order_resid_zip[,i] = sort(resid_zip[,i])
}

min_res_zip = numeric()
max_res_zip = numeric()
mean_res_zip = numeric()


for(i in 1:n){
min_res_zip[i]  = min(order_resid_zip[i,])
max_res_zip[i]  = max(order_resid_zip[i,])
mean_res_zip[i] = mean(order_resid_zip[i,])
}

faixa = range(td_zip,min_res_zip, max_res_zip)

qqnorm(td_zip,xlab="Quantiles of N(0,1)", ylim=faixa,ylab="Pearson residue", pch=16, main="ZIP")
par(new=T)
qqnorm(min_res_zip,axes=F,xlab="",ylab="",type="l", lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(max_res_zip,axes=F,xlab="",ylab="", type="l",lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(mean_res_zip,axes=F,xlab="", ylab="", type="l", lty=2, main="", ylim=faixa)


###############################################
############################ ZINB regression model 
###############################################

require(MASS)
aux <- glm.nb(cells ~ age*sex*smoker*weight, data=Dataset)
Dataset2 <- as.data.frame(model.matrix(aux))
Dataset2 <- Dataset2[, !is.na(coef(aux))]
Dataset2 <- Dataset2[,-1]
names(Dataset2)
Dataset2$cells <- Dataset$cells
names(Dataset2)

require(pscl)
require(lmtest)

fit.bn <- zeroinfl( cells ~. | 1, dist="negbin", data=Dataset2)

fit2.bn <- zeroinfl( cells ~. - `ageold:sexmale:smokerTRUE:weightobese` - `ageyoung:sexmale:smokerTRUE:weightover`| 1, dist="negbin", data=Dataset2)
summary(fit2.bn)

waldtest(fit.bn, fit2.bn)
lrtest(fit.bn, fit2.bn)

fit3.bn <- zeroinfl(cells ~ (sexmale + smokerTRUE + weightobese +  weightover + `sexmale:smokerTRUE` + `smokerTRUE:weightobese` + `smokerTRUE:weightover`)| 1, dist="negbin", data=Dataset2)
summary(fit3.bn)

waldtest(fit2.bn, fit3.bn)
lrtest(fit2.bn, fit3.bn)

### Note that fit3.bn = fit4.bn ####

fit4.bn <- zeroinfl( cells ~ sex + smoker + weight + smoker:weight + sex:smoker | 1, dist="negbin", data = Dataset)
summary(fit4.bn)

fit.model <- fit4.bn

 -2*logLik(fit.model)
AIC(fit.model)

BIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*log(length(cells))
BIC

CAIC  = -2*logLik(fit.model)[1] +  (dim(model.matrix(fit.model))[2] + 2)*(log(length(cells))+ 1)
CAIC


#---------------------------------------
# Envelope : ZINB regression model
#---------------------------------------

Xe  <-  model.matrix(fit.model)
X      = Xe
n      = nrow(X)
p      = ncol(X)
ls <- dim(model.matrix(fit.model))[2]
beta <- coef(fit.model)[1:ls]
p.zinb.lambda <- exp(X%*%as.matrix(beta))
p.zinb.theta <- fit.model$theta
p.zinb.omega <-  as.numeric((exp(-coef(fit.model)[ls+1])+1)^(-1))

td_zinb  = resid(fit.model,type="pearson")

mm       = 200

nresp_zinb = matrix(0,n,mm)

require(VGAM)

###---------------
### Generating mm samples of size n
###---------------

for(i in 1:mm){
  nresp_zinb[,i] = rzinegbin(n,size=p.zinb.theta,munb=p.zinb.lambda/(1-p.zinb.omega), pstr0 = p.zinb.omega) 
}

resid_zinb = matrix(0,n,mm)

for(i in 1:mm){
  fit             = zeroinfl(nresp_zinb[,i] ~ sex + smoker + weight + smoker:weight + sex:smoker | 1, dist = "negbin", data = Dataset, control = zeroinfl.control(EM = TRUE)) 
  resid_zinb[,i]  = resid(fit,type="pearson")
}

order_resid_zinb  = matrix(0,n,mm)

for(i in 1:mm){
  order_resid_zinb[,i] = sort(resid_zinb[,i])
}

min_res_zinb = numeric()
max_res_zinb = numeric()
mean_res_zinb = numeric()


for(i in 1:n){
min_res_zinb[i]  = min(order_resid_zinb[i,])
max_res_zinb[i]  = max(order_resid_zinb[i,])
mean_res_zinb[i] = mean(order_resid_zinb[i,])
}

faixa = range(td_zinb,min_res_zinb, max_res_zinb)

qqnorm(td_zinb,xlab="Quantiles of N(0,1)", ylim=faixa,ylab="Pearson residue", pch=16, main="ZINB")
par(new=T)
#
qqnorm(min_res_zinb,axes=F,xlab="",ylab="",type="l", lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(max_res_zinb,axes=F,xlab="",ylab="", type="l",lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(mean_res_zinb,axes=F,xlab="", ylab="", type="l", lty=2, main="", ylim=faixa)

###############################################
############################ Polya-Aeppli model 
###############################################

require(polyaAeppli)  # package of Plya-Aeppli distribution
y = cells

# Xe = model.matrix(~  age*sex*smoker*weight)
  Xe = model.matrix(~ smoker*weight)
dim(Xe)

f = function(theta1) {
  
  betae  = theta1[1:dim(Xe)[2]]
  rho    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))

  mu     = exp(Xe %*% betae)

  lambda = abs(mu*(1-rho))

  loglik = dPolyaAeppli(y, abs(lambda), rho, log = TRUE)

  sum(loglik)
}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP   = optim(theta0, f, control = list(fnscale = -1, maxit = 50000),  method = "L-BFGS-B")

AIC    = -2 * m.IP$value + 2 * length(m.IP$par)
BIC    = -2 * m.IP$value + length(m.IP$par) * log(length(y))
CAIC = -2 * m.IP$value + length(m.IP$par)*(log(length(y)) + 1)
cbind(c("AIC","BIC", "CAIC"),round(c(AIC,BIC, CAIC), 3))

Loglike <- m.IP$value
Loglike

#----------------------------------------
# Estimates
#----------------------------------------

betae     = m.IP$par[1:dim(Xe)[2]]
rho       =  1/(1+exp(-m.IP$par[dim(Xe)[2]+1]))  
mu        = exp(Xe %*% betae)

estimate  = c(betae,rho)
estimate
#----------------------------------------
# Standard error
#----------------------------------------

f2 = function(theta1) {
  
  betae  = theta1[1:dim(Xe)[2]]
  rho    = theta1[dim(Xe)[2]+1]
 
  mu     = exp(Xe %*% betae)

  lambda = mu*(1-rho)	
 
  loglik   = dPolyaAeppli(y, lambda, rho, log = TRUE)

  sum(loglik)
}

library(nlme)
obsinf  = -fdHess(estimate, f2)$Hessian
covmat  = solve(obsinf)
setheta = sqrt(diag(covmat))
LInf = estimate - qnorm(0.975)*setheta
LSup = estimate + qnorm(0.975)*setheta
mest    = cbind(estimate, setheta,(estimate) / setheta,  round(2*(1-pnorm(abs(estimate) / setheta)), 3), LInf, LSup)
colnames(mest) = c("Estimate", "s.e.", "z value", "P(> |z|)", "2,5%", "97,5")

print(mest)

#########################
############ EM-algorithm 
#########################
y      = cells

# Xe = model.matrix(~  age*sex*smoker*weight)
Xe = model.matrix(~ smoker*weight)
dim(Xe)

status = NULL
for(i in 1:length(y)){ if(y[i]==0) {status[i]=1}
else{status[i]=0}
}

require(hypergeo)

#---------------------------------------
## EM algorithm
#---------------------------------------

fit.EM <- function(y,status,param,tol=1e-4){# incio fit.EM

betae   = param[1:6]
rho     = param[7]

var.aux = function(){

mu      = exp(Xe %*% betae)
lambda  = mu*(1-rho)	
p       = NULL

for(i in 1:length(y)){

p[i]    = (genhypergeo(c(1-y[i]), c(1),lambda[i]*(rho-1)/rho)) / (genhypergeo(c(1-y[i]),c(2),lambda[i]*(rho-1)/rho))
}
p

}

f = function(theta1) {
  
  betae  = theta1[1:6]
  rho    = 1/(1+exp(-theta1[7]))
 
  mu     = exp(Xe %*% betae)

  lambda = mu*(1-rho)	
 
  loglik = 2*log(1-rho)*(1-status)*w+log(rho)*(1-status)*(y-w)+(1-status)*w*log(mu)-(1-rho)*mu

  sum(loglik)
}

test    = 1

while(test>tol){#incio while

w          = var.aux()

theta0     = c(betae,rho)
mgg        = optim(theta0, f, method = "SANN",control = list(fnscale = -1, maxit = 3000))
result     = mgg$value

while(result==-1e+35){

theta0     = c(betae,rho)
mgg        = optim(theta0, f, method = "SANN",control = list(fnscale = -1, maxit = 3000))
result     = mgg$value
}
theta0     = mgg$par
mgg        = optim(theta0, f, method = "L-BFGS-B",control = list(fnscale = -1, maxit = 1000))

betae1.new = mgg$par[1]
betae2.new = mgg$par[2]
betae3.new = mgg$par[3]
betae4.new = mgg$par[4]
betae5.new = mgg$par[5]
betae6.new = mgg$par[6]
rho.new    = 1/(1+exp(-mgg$par[7]))

test       = max(abs(c(((betae1.new-betae[1])),((betae2.new-betae[2])),((betae3.new-betae[3])), ((betae4.new-betae[4])), ((betae5.new-betae[5])), ((betae6.new-betae[6])), ((rho.new-rho)))))

betae      = c(betae1.new,betae2.new,betae3.new,betae4.new,betae5.new,betae6.new)
rho        = rho.new

}#fim while

c(betae,rho)

}#fim fit.EM

#-----------------
# Using the function
#-----------------

result = fit.EM(y,status, rep(0.1, 7))

library(nlme)

#---
# Standard error

betae      = result[1:6]
rho        = result[7]

Estimate = c(betae,rho)

library(nlme)
obsinf2  = -fdHess(Estimate, f2)$Hessian
covmat2  = solve(obsinf2)
setheta2 = sqrt(diag(covmat2))
LInf2 = Estimate - qnorm(0.975)*setheta
LSup2 = Estimate + qnorm(0.975)*setheta
mest2    = cbind(Estimate, setheta2,(Estimate) / setheta2,  round(2*(1-pnorm(abs(Estimate) / setheta2)), 3), LInf2, LSup2)
colnames(mest2) = c("Estimate", "s.e.", "z value", "P(> |z|)", "2,5%", "97,5")

print(mest2)

#---------------------------------------
# Envelope : Log-Plya-Aeppli regression model
#---------------------------------------

par(mfrow=c(1,1))

X     = Xe
n     = nrow(X)
p     = ncol(X)
td    = (y-mu)/sqrt(mu*(1+rho)/(1-rho))
td    = sort(td)

mm    = 200

nresp = matrix(0,n,mm)

###---------------
### Generating mm samples of size n

for(i in 1:mm){
nresp[,i] = rPolyaAeppli(n, mu*(1-rho), rho)
}

###---------------
### Adjusting mm samples with the same variables

beta_ss = matrix(0, p, mm)
rho_ss  = numeric()

for(i in 1:mm){

	f_s = function(theta1){
  
   		beta_s   = theta1[1:dim(Xe)[2]]
   		rho_s    = 1/(1+exp(-theta1[dim(Xe)[2]+1])) 

   		mu_s     = exp(Xe %*% beta_s)

  		 lambda_s = mu_s*(1-rho_s)	
 
   		loglik   = dPolyaAeppli(nresp[,i], lambda_s, rho_s, log = TRUE)

  		sum(loglik)
	}

theta0 = m.IP$par
m.IP_s = optim(theta0, f_s, control = list(fnscale = -1, maxit = 1000), method = "L-BFGS-B")

rho_ss[i] = 1/(1+exp(-m.IP_s$par[dim(Xe)[2]+1]))  

		for (j in 1:p){
  
 		 beta_ss[j,i] = m.IP_s$par[j]

 		}
}

mu_ss = matrix(0,n,mm)

for(i in 1:mm){
  mu_ss[,i] = exp(Xe %*% beta_ss[, i])
}

resid = matrix(0,n,mm)

for(i in 1:mm){
  resid[,i]  = (nresp[,i]-mu_ss[,i])/sqrt(mu_ss[,i]*(1+rho_ss[i])/(1-rho_ss[i]))
}

order_resid = matrix(0,n,mm)

for(i in 1:mm){
  order_resid[,i] = sort(resid[,i])
}


min_res = numeric()
max_res = numeric()
mean_res = numeric()

for(i in 1:n){
  min_res[i]  = min(order_resid[i,])
  max_res[i]  = max(order_resid[i,])
  mean_res[i] = mean(order_resid[i,])
}

faixa = range(td,min_res, max_res)

par(pty="s")
qqnorm(td,xlab="Quantiles of N(0,1)", ylim=faixa,ylab="Pearson residue", pch=16, main=" Plya-Aeppli")
par(new=T)
#
qqnorm(min_res,axes=F,xlab="",ylab="",type="l", lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(max_res,axes=F,xlab="",ylab="", type="l",lty=1, main="", ylim=faixa)
par(new=T)
qqnorm(mean_res,axes=F,xlab="", ylab="", type="l", lty=2, main="", ylim=faixa)

#---------------------------------------
# Likelihood Ratio Test (rho=0) vs Polya-Aeppli
#---------------------------------------

fit.model_po = glm(y   ~  smoker*weight, family = "poisson")
log.vero_Po <- logLik(fit.model_po)[1] 

log.vero_PA = m.IP$value

LRS = -2*(log.vero_Po-log.vero_PA)
LRS

1-pchisq(LRS, 1)

###############################
#################### Diagnostic
###############################

p = ncol(Xe)

Delete_est = matrix(0,  p + 1, length(y))

Delete_l  = numeric()
rho_ss = numeric()

for(i in 1:length(y)){

f_s = function(theta1) {
  
   beta_s   = theta1[1:dim(Xe)[2]]
   rho_s    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))

   mu_s     = exp(Xe[-i,] %*% beta_s)

   lambda_s = mu_s*(1-rho_s)	
 
   loglik   = dPolyaAeppli(y[-i], lambda_s, rho_s, log = TRUE)

  sum(loglik)
}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP_s = optim(theta0, f_s, control = list(fnscale = -1, maxit = 10000, trace = FALSE), method = "L-BFGS-B")

rho_ss[i] = 1/(1+exp(-m.IP_s$par[dim(Xe)[2]+1]))  

for (j in 1:p){
  
Delete_est[j,i] = m.IP_s$par[j]

}

Delete_est[p+1,i] = rho_ss[i]
Delete_l[i] =  m.IP_s$value

}

#---------------------------------------
# Generalized Cooks distance
#---------------------------------------

GD_i = numeric()

for(i in 1:length(y)){
GD_i[i] = (Delete_est[,i]-estimate)%*%(obsinf)%*%(Delete_est[,i]-estimate)
}

plot(GD_i, ylab = expression(GD[i]), main ="Generalized Cooks distance")
identify(GD_i, n=8)

#---------------------------------------
# Likelihood distance
#---------------------------------------

LD_i = numeric()

for(i in 1:length(y)){
LD_i[i] = abs(2*(m.IP$value - Delete_l[i]))
}

plot(LD_i, ylab = expression(LD[i]), main="Likelihood distance")
identify(LD_i, n=12)

###################################################################
####### Assessing the influence of observations on the estimates 
###################################################################

i = c(338, 400, 133,135,136,138,139,140, 9, 46, 126, 127, 182, 198, 354, 382, 395, 456)

f_si = function(theta1) {
  
   beta_s   = theta1[1:dim(Xe)[2]]
   rho_s    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))

   mu_s     = exp(Xe[-i,] %*% beta_s)

   lambda_s = mu_s*(1-rho_s)	
 
   loglik   = dPolyaAeppli(y[-i], lambda_s, rho_s, log = TRUE)

  sum(loglik)
}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP_si = optim(theta0, f_si, control = list(fnscale = -1, maxit = 10000, trace = FALSE), method = "L-BFGS-B", hessian = TRUE)

rho_ss[i] = 1/(1+exp(-m.IP_si$par[dim(Xe)[2]+1]))

#----------------------------------------
# Estimates
#----------------------------------------

beta_i     = m.IP_si$par[1:dim(Xe)[2]]
rho_i       =  1/(1+exp(-m.IP_si$par[dim(Xe)[2]+1]))  

mu_i        = exp(Xe[-i,] %*% beta_i)

estimate_i  = c(beta_i,rho_i)

#----------------------------------------
# Standard error
#----------------------------------------

f2_i = function(theta1) {
  
  betae  = theta1[1:dim(Xe)[2]]
  rho    = theta1[dim(Xe)[2]+1]
 
  mu     = exp(Xe[-i,] %*% betae)

  lambda = mu*(1-rho)	
 
  loglik   = dPolyaAeppli(y[-i], lambda, rho, log = TRUE)

  sum(loglik)
}

library(nlme)
obsinf_i  = -fdHess(estimate_i, f2_i)$Hessian
covmat_i  = solve(obsinf_i)
setheta_i = sqrt(diag(covmat_i))
LInf_i = estimate_i - qnorm(0.975)*setheta_i
LSup_i = estimate_i + qnorm(0.975)*setheta_i
mest_i    = cbind(estimate_i, setheta_i,(estimate_i) / setheta_i, 2*(1-pnorm(abs(estimate_i) / setheta_i)), LInf_i, LSup_i)
colnames(mest_i) = c("Estimate", "s.e.", "z value", "P(> |z|)", "2,5%", "97,5")

print(mest_i)

#----------------------------------------
# likelihood ratio statistics - Poisson (rho=0) vs Polya-Aeppli (with excluded #observations)
#----------------------------------------


fit.model = glm(y[-i] ~ Xe[-i,], family = poisson)
log.vero_PO = logLik(fit.model)[1]
log.vero_PA = m.IP_si$value

LRS = -2*(log.vero_PO-log.vero_PA)
LRS

1-pchisq(LRS, 1)

######################################################
######################################################
##### Predictive measures: Cells by Smoker and Weight (Table 9). The following R code for the analyses of Table 9 was adapted from Supplementary Material of Czado, C., Gneiting, T., and Held, L. (2009).
##### Czado, C., Gneiting, T., and Held, L. (2009). Predictive model assessment for count data. Biometrics, 65, 1254-1261. Supplementary materials are avaliable at http://www.biometrics.tibs.org. (Acessed on 10/10/2016).
######################################################
######################################################

n <- length(cells)

### count regressions in cross validation mode 

### negative binomial regression 

p.nb.lambda <- rep(0,n)
p.nb.theta <- rep(0,n)
p.nb.Px <- rep(0,n)
p.nb.Px1 <- rep(0,n)
p.nb.px <- rep(0,n) 
 
library(MASS)    

Xe     = model.matrix(~ smoker*weight)
dim(Xe)

for (i in 1:n)
  {
  temp <- glm.nb(cells[-i] ~ smoker[-i]*weight[-i])
  beta <- coef(temp)
  p.nb.lambda[i] <- exp(Xe[i,] %*% beta)
  p.nb.theta[i] <- temp$theta
  p.nb.Px[i] <- pnbinom(cells[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.Px1[i] <- pnbinom(cells[i]-1,size=p.nb.theta[i],mu=p.nb.lambda[i])
  p.nb.px[i] <- dnbinom(cells[i],size=p.nb.theta[i],mu=p.nb.lambda[i])
  }

### PA regression

p.pa.lambda <- rep(0,n)
p.pa.rho <- rep(0,n)
p.pa.Px <- rep(0,n)
p.pa.px <- rep(0,n) 

 y = cells
 x1 <- factor(smoker)
 x2 <- factor(weight)

 Xe     = model.matrix(~ x1*x2)

require(polyaAeppli)  # package of Plya-Aeppli distribution

for (i in 1:n){

  	f = function(theta1) {
		betae  = theta1[1:dim(Xe)[2]]
  		rho    = 1/(1+exp(-theta1[dim(Xe)[2]+1]))
 		mu     = exp(Xe[-i,] %*% betae)
		lambda = mu*(1-rho)	
 		loglik = dPolyaAeppli(y[-i], lambda, rho, log = TRUE)
 	 	sum(loglik)
	}

theta0 = rep(0.1,dim(Xe)[2]+1)
m.IP   = optim(theta0, f, control = list(fnscale = -1, trace = FALSE, maxit = 10000),  method = "L-BFGS-B")

beta <- m.IP$par[1:dim(Xe)[2]]
p.pa.lambda[i] <- exp(Xe[i,] %*% beta)
p.pa.rho[i] <-  1/(1+exp(-m.IP$par[dim(Xe)[2]+1]))
p.pa.Px[i] <- pPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
p.pa.px[i] <- dPolyaAeppli(y[i], p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])
}

### parameter settings for computing scores

kk <- 100000                              ### cut-off for summations 
my.k <- (0:kk)                          ### to handle ranked probability score

##################
### compute scores
##################

### Negative binomial regression 

p.nb.px <- dnbinom(cells,mu=p.nb.lambda,size=p.nb.theta)
p.nb.logs <- - log(p.nb.px)
  p.nb.norm <- 1:n
  for (i in 1:n) 
    {p.nb.norm[i] <- sum(dnbinom(my.k,mu=p.nb.lambda[i],size=p.nb.theta[i])^2)} 
p.nb.qs <- - 2*p.nb.px + p.nb.norm
p.nb.sphs <- - p.nb.px / sqrt(p.nb.norm)
p.nb.rps <- 1:n 
  for (i in 1:n) 
    {
    p.nb.rps[i] <- sum(pnbinom((-1):(cells[i]-1),mu=p.nb.lambda[i],size=p.nb.theta[i])^2) 
    p.nb.rps[i] <- p.nb.rps[i] + sum((pnbinom(cells[i]:kk,mu=p.nb.lambda[i],size=p.nb.theta[i])-1)^2)
    }
p.nb.dss <- (cells-p.nb.lambda)^2/(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)) + 2*log(sqrt(p.nb.lambda*(1+p.nb.lambda/p.nb.theta)))
p.nb.ses <- (cells-p.nb.lambda)^2

### Polya-Aeppli regression 

p.pa.px <- dPolyaAeppli(cells, p.pa.lambda*(1-p.pa.rho), p.pa.rho) 
p.pa.logs <- - log(p.pa.px)
  p.pa.norm <- 1:n
  for (i in 1:n) 
    {p.pa.norm[i] <- sum(dPolyaAeppli(my.k, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2)} 
p.pa.qs <- - 2*p.pa.px + p.pa.norm
p.pa.sphs <- - p.pa.px / sqrt(p.pa.norm)
p.pa.rps <- 1:n 
  for (i in 1:n) 
    {
    p.pa.rps[i] <- sum(pPolyaAeppli((-1):(cells[i]-1), p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])^2) 
    p.pa.rps[i] <- p.pa.rps[i] + sum((pPolyaAeppli(cells[i]:kk, p.pa.lambda[i]*(1-p.pa.rho[i]), p.pa.rho[i])-1)^2)
    }
p.pa.dss <- (cells-p.pa.lambda)^2/(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))) + 2*log(sqrt(p.pa.lambda*((1+p.pa.rho)/(1-p.pa.rho))))
p.pa.ses <- (cells-p.pa.lambda)^2

### reproduce Table 9 column by column 

round(c(mean(p.nb.logs), mean(p.pa.logs)), 2)    ### logarithmic score
round(c(mean(p.nb.qs), mean(p.pa.qs)), 2)        ### quadratic score
round(c(mean(p.nb.sphs), mean(p.pa.sphs)),2)     ### spherical score  
round(c(mean(p.nb.rps), mean(p.pa.rps)),2)       ### ranked probability score
round(c(mean(p.nb.dss), mean(p.pa.dss)),2)       ### Dawid-Sebastiani score
round(c(mean(p.nb.ses), mean(p.pa.ses)), 2)      ### squared error score   

